;;########################################################################
;; regvis1.lsp
;; This file contains moral-spreadplot-supervisor-proto code
;; Visualization for OLS, Robust & Monotonic Regression ViSta model object
;; Copyright (c) 1995-1996 by Carla M. Bann
;; Copyright (c) 1997-2000 by Carla M. Bann and Forrest W. Young
;;########################################################################


(setf plot-size  
          (min (- (floor (/ (first screen-size) 3))
                  window-decoration-width 2)
               (- (floor (/ (- (second screen-size) menu-bar-height) 2))
                  msdos-fiddle ;fwy
                  (/ window-decoration-height 2))))
    


(defmeth morals-model-object-proto :create-spreadplot (&optional show)
"Method args: (&optional show)"
  (let* ( (mssp nil)))
  (when (not (send self :spreadplot-supervisor))
        (setf mssp (send morals-spreadplot-supervisor-proto :new :model self))
        (send mssp :simple-reg (= 1 (length (send self :iv))))
        (send mssp :location-array)
        (send mssp :create-plots)
        (when (not (send mssp :simple-reg)) (send mssp :new-menu))
        (send self :spreadplot-supervisor mssp)
(send mssp :menu nil); kills spreadplot menu but makes iterative methods ng
        (when (not (equalp show "no")) (send mssp :show-ssp))
        mssp)
  (when (send self :spreadplot-supervisor)
        (when (not (equalp show "no")) 
              (send self :show-spreadplot-supervisor))
        (send self :spreadplot-supervisor))
  )


(defproto spreadplot-supervisor-proto 
  '( model menu  menu-title menu-template) '() spreadplot-proto) ;*object*


(defmeth spreadplot-supervisor-proto :isnew 
  (&key  model  (menu-title "SpreadPlot") (menu-template '(dash dash dash)) )
  (if model (setf (slot-value 'model) model))
  (if menu-title (setf (slot-value 'menu-title) menu-title))
  (if menu-template (setf (slot-value 'menu-template) menu-template))  )

(defmeth spreadplot-supervisor-proto :model (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the model in which the spreadplot is installed."
  (if set (setf (slot-value 'model) values))
  (slot-value 'model) )

(defmeth spreadplot-supervisor-proto :menu (&optional (values nil set))
"Method Args:  &optional MENU
Sets or retrieves the spreadplot's menu in its MENU slot."
  (if set (setf (slot-value 'menu) values))
  (slot-value 'menu) )

(defmeth spreadplot-supervisor-proto :menu-title (&optional (values nil set))
"Method Args:  &optional ''TITLE''
Sets or retrieves the title of the spreadplot's menu."
  (if set (setf (slot-value 'menu-title) values))
  (slot-value 'menu-title) )

(defmeth spreadplot-supervisor-proto :menu-template (&optional (values nil set))
"Method Args:  &optional TEMPLATE
Sets or retrieves the template of items for the spreadplot's menu."
  (if set (setf (slot-value 'menu-template) values))
  (slot-value 'menu-template) )

(defmeth spreadplot-supervisor-proto :remove ()
"Method Args: () 
Removes the spreadplot.  First, remove its menu if it has one.  Then, remove the individual plots installed in it. "

  (when (send self :menu)
        (send (send self :menu) :remove)
        (send (send self :menu) :dispose) )
  (mapcar #'(lambda (plot) 
              (when plot
                    (if (send plot :allocated-p)
                        (send plot :remove))))
              (send self :all-plots)) )



(defmeth spreadplot-supervisor-proto :show-ssp ()
"Method Args: () 
Shows the spreadplot.  First, installs its menu (if it has one) into the menu bar.  Then, shows the individual plots installed in it. "
  (send self :show-visible-plots))


(defmeth spreadplot-supervisor-proto :new-menu 
  (&optional title  &key (items (send self :menu-template)) ) 
  (unless title 
          (setq title (slot-value 'menu-title)) )
  (if (slot-value 'menu) 
      (send (slot-value 'menu) :dispose) )
  (flet (
         (make-item (item) (send self :make-menu-item item) )
         )
    (let (
          (menu (send menu-proto :new title) )
          )
      (send self :menu menu) 
      (apply #'send menu :append-items  
             (remove nil (mapcar #'make-item items)))
      menu) ) )


(defmeth spreadplot-supervisor-proto :make-menu-item (item-template)
  (if (kind-of-p item-template menu-item-proto)
      item-template
      (case item-template
        ( dash (send dash-item-proto :new) ) 
        ( show-plots 
          (send graph-item-proto :new "Show Plots" self 
                :show-visible-plots) )
        ( hide-plots 
          (send graph-item-proto :new "Hide Plots" self 
                :hide-all-plots) )
        ( show-spreadplot 
          (send graph-item-proto :new "Show SpreadPlot" self 
                :show-ssp) )
        ( hide-spreadplot 
          (send graph-item-proto :new "Hide SpreadPlot" self 
                :hide-ssp) )
        ( kill-spreadplot
          (send graph-item-proto :new "Kill SpreadPlot" (slot-value 'model)
                :delete-spreadplot-supervisor) )

        )))


(defmeth spreadplot-supervisor-proto :all-plots ()
"Method Args: () 
Retrieves the list of a spreadplot-object's own slots and checks whether they are plots or not.  Returns a list of all plots from the object's slots. Note: expects any slot to contain one and only one plot. " 
(let ((slots (mapcar #'(lambda (x)
                         (send self :slot-value x))
                     (send self :own-slots))))
  (select slots (which (mapcar #'(lambda (x) 
                                   (kind-of-p x graph-proto))
                               slots))) ))


(defmeth spreadplot-supervisor-proto :hide-all-plots ()
(PRINT "REG SSP HIDE ALL PLOTS")
  (mapcar #'(lambda (x)
              (send x :hide-window)
              (send (send x :menu) :remove))
          (send self :all-plots)))


(defmeth spreadplot-supervisor-proto :show-visible-plots ()
  (mapcar #'(lambda (x)
              (send x :show-window))
          (send self :all-plots)))



;****MORALS SPREADPLOT******


(defproto morals-spreadplot-supervisor-proto 
  '(rsq-beta-plot CHANGE-PLOT residual-plot1 residual-plot2 influence-plot1    
    influence-plot2 transformation-plot simple-reg confidence-intervals
    lin-reg-plot  infl-type1 infl-type2 resid-type1 resid-type2
    var-list obs-list robust-plot robust-reg-plot added-var-plot
    obs-plots iter-container)
  '()
  spreadplot-supervisor-proto)



(defmeth morals-spreadplot-supervisor-proto :isnew 
  (&rest args &key model plots menu (menu-title "SpreadPlot" mti-test)
  (menu-template 
       '(rsq-plot trans-plot3 av-plot resid-plot1 resid-plot2 infl-plot1 
         infl-plot2 var-list obs-list) mte-test)  
  residual-plot1 residual-plot2 influence-plot1 influence-plot2  
  transformation-plot lin-reg-plot rsq-beta-plot var-list obs-list
  added-var-plot)

(let* (
      (args2 (if mti-test 
                 args
                 (append args (list :menu-title menu-title))))
      (args3 (if mte-test
                 args2
                 (append args2 (list :menu-template menu-template))))
       ) 
  (apply #'call-next-method args3)
))

(defmeth morals-spreadplot-supervisor-proto :iter-container (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of iteration container."
  (if set (setf (slot-value 'iter-container) values))
  (slot-value 'iter-container) )

(defmeth morals-spreadplot-supervisor-proto :rsq-beta-plot (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the rsq-beta plot."
  (if set (setf (slot-value 'rsq-beta-plot) values))
  (slot-value 'rsq-beta-plot) )


(defmeth morals-spreadplot-supervisor-proto :change-plot 
  (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the rsq-beta change plot."
  (if set (setf (slot-value 'change-plot ) values))
  (slot-value 'change-plot ) )


(defmeth morals-spreadplot-supervisor-proto :residual-plot1 (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the model in which the spreadplot is installed."
  (if set (setf (slot-value 'residual-plot1) values))
  (slot-value 'residual-plot1) )


(defmeth morals-spreadplot-supervisor-proto :influence-plot1 (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the model in which the spreadplot is installed."
  (if set (setf (slot-value 'influence-plot1) values))
  (slot-value 'influence-plot1) )


(defmeth morals-spreadplot-supervisor-proto :transformation-plot (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the model in which the spreadplot is installed."
  (if set (setf (slot-value 'transformation-plot) values))
  (slot-value 'transformation-plot) )

(defmeth morals-spreadplot-supervisor-proto :residual-plot2 (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the model in which the spreadplot is installed."
  (if set (setf (slot-value 'residual-plot2) values))
  (slot-value 'residual-plot2) )


(defmeth morals-spreadplot-supervisor-proto :influence-plot2 (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the model in which the spreadplot is installed."
  (if set (setf (slot-value 'influence-plot2) values))
  (slot-value 'influence-plot2) )


(defmeth morals-spreadplot-supervisor-proto :lin-reg-plot (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the model in which the spreadplot is installed."
  (if set (setf (slot-value 'lin-reg-plot) values))
  (slot-value 'lin-reg-plot) )

(defmeth morals-spreadplot-supervisor-proto :added-var-plot (&optional (values nil set))
"Method Args:  &optional (VALUES nil) 
Sets or retrieves the object id# of the model in which the spreadplot is installed."
  (if set (setf (slot-value 'added-var-plot) values))
  (slot-value 'added-var-plot) )

(defmeth morals-spreadplot-supervisor-proto :infl-type1 (&optional (values nil set))
  (if set (setf (slot-value 'infl-type1) values))
  (slot-value 'infl-type1) )

(defmeth morals-spreadplot-supervisor-proto :resid-type1 (&optional (values nil set))
  (if set (setf (slot-value 'resid-type1) values))
  (slot-value 'resid-type1) )

(defmeth morals-spreadplot-supervisor-proto :infl-type2 (&optional (values nil set))
  (if set (setf (slot-value 'infl-type2) values))
  (slot-value 'infl-type2) )

(defmeth morals-spreadplot-supervisor-proto :resid-type2 (&optional (values nil set))
  (if set (setf (slot-value 'resid-type2) values))
  (slot-value 'resid-type2) )

(defmeth morals-spreadplot-supervisor-proto :confidence-intervals 
  (&optional (nilt nil set))
  (if set (setf (slot-value 'confidence-intervals) nilt))
  (slot-value 'confidence-intervals) )

(defmeth morals-spreadplot-supervisor-proto :var-list (&optional (values nil set))
  (if set (setf (slot-value 'var-list) values))
  (slot-value 'var-list) )

(defmeth morals-spreadplot-supervisor-proto :obs-list (&optional (values nil set))
  (if set (setf (slot-value 'obs-list) values))
  (slot-value 'obs-list) )


(defmeth morals-spreadplot-supervisor-proto :robust-plot (&optional (values nil set))
  (if set (setf (slot-value 'robust-plot) values))
  (slot-value 'robust-plot) )

(defmeth morals-spreadplot-supervisor-proto :robust-reg-plot (&optional (values nil set))
  (if set (setf (slot-value 'robust-reg-plot) values))
  (slot-value 'robust-reg-plot) )

(defmeth morals-spreadplot-supervisor-proto :simple-reg (&optional (values nil set))
  (if set (setf (slot-value 'simple-reg) values))
  (slot-value 'simple-reg) )


(defmeth morals-spreadplot-supervisor-proto :obs-plots (&optional (obj-list nil arg-used))
  (if arg-used (setf (slot-value 'obs-plots) obj-list))
  (slot-value 'obs-plots))
          

(defmeth morals-spreadplot-supervisor-proto :location-array ()
  (let* ((location (make-array (list 2 3))))
    (dotimes (i 2)
         (dotimes (j 3)
              (setf (aref location i j)
                    (list (* j (+ plot-size window-decoration-width 3));i
                          (+ (* i (+ plot-size 2))
                             (* msdos-fiddle (+ 1 i));fwy 4.27
                        #+X11 (+ 5 (* 28 (+ (* 2 i) 1))) ;fwy 4.27
                             (* (1+ i) window-decoration-height))))))
    (setf loc11 (select location 0 0))
    (setf loc12 (select location 0 1))
    (setf loc13 (select location 0 2))
    (setf loc21 (select location 1 0))
    (setf loc22 (select location 1 1))
    (setf loc23 (select location 1 2))))

(defmeth morals-spreadplot-supervisor-proto :close-dialog (plot)
  (send self :remove) ;hide-ssp
  (send (send plot :menu) :remove)
  (send (send self :model) :spreadplot-supervisor nil)
  (setf *current-spreadplot* nil)
  )

(defmeth morals-spreadplot-supervisor-proto :make-menu-item (item-template)
  (if (kind-of-p item-template menu-item-proto)
      item-template
      (case item-template
        ( resid-plot1 (send graph-item-proto :new "Residual Plot-1"
                      (send self :residual-plot1) :show-plot) )
        ( resid-plot2 (send graph-item-proto :new "Residual Plot-2"
                            (if (send self :residual-plot2)
                                (send self :residual-plot2)
                                self)  :show-plot) )
        ( av-plot (send graph-item-proto :new "Added Variables Plot"
                        (if (send self :added-var-plot) (send self :added-var-plot)
                            self) :show-plot))
        ( infl-plot1 (send graph-item-proto :new "Influence Plot-1"
                           (if (send self :influence-plot1)
                               (send self :influence-plot1)
                               self)  :show-plot))
        ( infl-plot2 (send graph-item-proto :new "Influence Plot-2"
                          (if (send self :influence-plot2)
                               (send self :influence-plot2)
                               self)  :show-plot))
        ( trans-plot1 (send graph-item-proto :new "Fit/Transformation Plot"
                          (if (send self :transformation-plot)
                               (send self :transformation-plot)
                               self) :show-plot))
        ( trans-plot3 (send graph-item-proto :new "OLS Fit Plot"
                          (if (send self :transformation-plot)
                              (send self :transformation-plot)
                              self) :show-plot))
        ( trans-plot2 (send graph-item-proto :new "OLS Regression Plot"
                          (if (send self :lin-reg-plot)
                               (send self :lin-reg-plot)
                               self) :show-plot))
        ( rsq-plot (send graph-item-proto :new "RSQ-Beta Plot"
                        (if (send self :rsq-beta-plot)
                            (send self :rsq-beta-plot)
                            self) :show-plot))
       ; ( var-list (send graph-item-proto :new "Variable List"
       ;                 (if (send self :var-list)
       ;                     (send self :var-list)
       ;                     self) :show-window))
        ( obs-list (send graph-item-proto :new "Observation List"
                        (if (send self :obs-list)
                            (send self :obs-list)
                            self) :show-window))
        ( robust-plot (send graph-item-proto :new "Robust Weights Plot"
                        (if (send self :robust-plot)
                            (send self :robust-plot)
                            self) :show-window))
        ( robust-reg-plot (send graph-item-proto :new "Robust Fit Plot"
                        (if (send self :robust-reg-plot)
                            (send self :robust-reg-plot)
                            self) :show-window))
        ( t (call-next-method item-template))
        
)))

(defmeth morals-spreadplot-supervisor-proto :show-visible-plots () 
  (mapcar #'(lambda (x)
              (when (send x :showing) (send x :show-window)))
          (send self :all-plots)))

(defmeth morals-spreadplot-supervisor-proto :hide-all-plots ()
  (mapcar #'(lambda (x)
              (send x :hide-window))
          (send self :all-plots)))

(defmeth morals-spreadplot-supervisor-proto :get-residuals (plot &optional choice)  
  (let* (
         (resid-list (list "MR-Raw" "MR-Bayes" "MR-Student" "MR-External"  
                           "RR-Raw" "RR-Bayes" "RR-Student" "RR-External"
                           "LR-Raw" "LR-Bayes" "LR-Student" "LR-External"))
         (mod (send self :model))        
         (morals-model (send mod :morals-model))
         (model (if (equalp (send mod :method) "Robust") 
                    (send mod :robust-model) morals-model))
         (lin-reg (send mod :lin-reg-model))
         (dv2 (select (send mod :variables) (send mod :dv)))
         (dv (if (listp dv2) (select dv2 0) dv2))
         (opred (strcat "Fitted " dv))
         (mpred (strcat "Fitted " dv))
         (rpred (strcat "Fitted" dv))
         (pindex nil)
         (i 0)
         (initial-index nil)
         (resid-type nil)
        ; (choice nil)
         (r (/ (send model :residuals) (send model :sigma-hat)))
         (r2 (/ (send lin-reg :residuals) (send lin-reg :sigma-hat)))
         (d (* 2 (sqrt (send model :leverages))))
         (low (- r d))
         (high (+ r d))
         (d2 (* 2 (sqrt (send lin-reg :leverages))))
         (low2 (- r2 d2))
         (high2 (+ r2 d2))
         (x-values (send model :fit-values))
         (x-values2 (send lin-reg :fit-values))
         (labels (send mod :labels))
         (color 'black)
         (npts (send (send self :transformation-plot) :num-points))
         (point-colors (send (send self :transformation-plot) :point-color (iseq npts)))
         (point-symbols)
        )
    #+color(when (> *color-mode* 0) (setf color 'blue))
    (if (equalp plot (send self :residual-plot1)) (setf pindex 1) (setf pindex 2)) 
    (if (= pindex 1) (setf resid-type (send self :resid-type1)) 
        (setf resid-type (send self :resid-type2)))
    (dotimes (i 12)
             (if (equalp resid-type (select resid-list i))
                  (setf initial-index i)))
    (unless choice 
            (when (equalp (send mod :method) "OLS")
                  (setf choice (choose-item-dialog "Choose type of residuals: "
                         '("Residuals"
                          "Bayes Residuals"
                           "Standardized Residuals")
                         :initial (- initial-index 8)))) 
            (when (equalp (send mod :method) "Monotonic")
                  (if (< initial-index 8)
                      (setf initial-index (+ initial-index 3))
                      (setf initial-index (- initial-index 8)))
                  (setf choice (choose-item-dialog "Choose type of residuals: "
                  '("OLS Residuals" 
                    "Bayes OLS Residuals"
                    "Standardized OLS Residuals" 
                  ;  "Externally Standardized Residuals"
                    "Raw Monotone Residuals" 
                    "Bayes Monotone Residuals" 
                    "Standardized Monotone Residuals" 
                   ; "Externally Standardized Monotone Residuals" 
                         ) 
                    :initial initial-index)))
            (when (equalp (send mod :method) "Robust")
                  (if (< initial-index 8)
                      (setf initial-index (+ initial-index 3))
                      (setf initial-index (- initial-index 8)))
                  (setf choice (choose-item-dialog "Choose type of residuals: "
                  '("OLS Residuals" 
                    "Bayes OLS Residuals"
                    "Standardized OLS Residuals" 
                  ;  "Externally Standardized OLS Residuals"
                    "Weighted Robust Residuals"
                    "Bayes Robust Residuals"
                    "Standardized Robust Residuals"
                  ;  "Externally Standardized Robust Residuals"
                         ) 
                    :initial initial-index)))
            (if choice (when (> choice 2) (setf choice (+ choice 1)))))
    (case choice
      (0 (send plot :point-coordinates 0 (send lin-reg :fit-values))
         (send plot :point-coordinates 1 (send lin-reg :raw-residuals))
     #| (0 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send lin-reg :fit-values)
               (send lin-reg :raw-residuals) 
              ; :color point-colors
               :point-labels labels)
         (mapcar #'(lambda (i color)
                     (send plot :point-colors i color))
                 (iseq npt) point-colors)
           |#
         (send plot :variable-label '(0 1) (list opred "OLS Residuals"))
         (send plot :abline 0 0)
         (send plot :adjust-to-data) 
         (if (= pindex 1) (send self :resid-type1 "LR-Raw") (send self :resid-type2 "LR-Raw")))
      (1 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points x-values2 r2 
               :color point-colors 
               :point-labels labels)
         (map 'list #'(lambda (a b c d) (send plot :plotline a b c d nil))
               x-values2 low2 x-values2 high2)
         (send plot :abline 0 0)
         (send plot :variable-label '(0 1) (list opred "Bayes OLS Residuals"))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "LR-Bayes") (send self :resid-type2 "LR-Bayes")))
      (2 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send lin-reg :fit-values)
               (send lin-reg :studentized-residuals) 
               :color color :point-labels labels)
         (send plot :abline 0 0)
         (send plot :variable-label '(0 1) (list opred "Standardized OLS Residuals")) 
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "LR-Student") (send self :resid-type2 "LR-Student")))
      (3 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send lin-reg :fit-values) 
               (send lin-reg :externally-studentized-residuals)
               :color color :point-labels labels)
         (send plot :abline 0 0)
         (send plot :variable-label '(0 1) (list opred "Externally Standardized OLS Residuals"))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "LR-External") (send self :resid-type2 "LR-External")))
      (4 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send model :fit-values)
               (send model :residuals) :color color :point-labels labels)
         (send plot :abline 0 0)
         (if (equalp (send mod :method) "Robust")
             (send plot :variable-label '(0 1) 
                   (list rpred "Weighted Robust Residuals"))
             (send plot :variable-label '(0 1) 
                   (list mpred "Monotone Residuals")))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "MR-Raw") (send self :resid-type2 "MR-Raw")))
      (5 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points x-values r :color color :point-labels labels)
         (send plot :abline 0 0)
         (map 'list #'(lambda (a b c d) (send plot :plotline a b c d nil))
               x-values low x-values high)
         (if (equalp (send mod :method) "Robust")
             (send plot :variable-label '(0 1)
                   (list rpred "Bayes Robust Residuals"))
             (send plot :variable-label '(0 1) 
                   (list mpred "Bayes Monotone Residuals")))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "MR-Bayes") (send self :resid-type2 "MR-Bayes")))
      (6 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send model :fit-values)
               (send model :studentized-residuals) 
               :color color :point-labels labels)
         (send plot :abline 0 0)
         (if (equalp (send mod :method) "Robust")
             (send plot :variable-label '(0 1)
                   (list rpred "Standardized Robust Residuals"))
             (send plot :variable-label '(0 1) 
                   (list mpred "Standardized Monotone Residuals")))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "MR-Student") (send self :resid-type2 "MR-Student")))
      (7 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send model :fit-values) 
               (send model :externally-studentized-residuals)
               :color color :point-labels labels)
         (send plot :abline 0 0)
         (if (equalp (send mod :method) "Robust")
             (send plot :variable-label '(0 1)
                   (list rpred "Externally Standardized Robust Residuals"))
             (send plot :variable-label '(0 1) 
                   (list mpred "Externally Standardized Monotone Residuals")))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "MR-External") (send self :resid-type2 "MR-External")))

      )
    ))
